home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclCmdMZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  52.3 KB  |  2,155 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  *
  15.  * SCCS: @(#) tclCmdMZ.c 1.102 97/08/13 10:06:58
  16.  */
  17.  
  18. #include "tclInt.h"
  19. #include "tclPort.h"
  20. #include "tclCompile.h"
  21.  
  22. /*
  23.  * Structure used to hold information about variable traces:
  24.  */
  25.  
  26. typedef struct {
  27.     int flags;            /* Operations for which Tcl command is
  28.                  * to be invoked. */
  29.     char *errMsg;        /* Error message returned from Tcl command,
  30.                  * or NULL.  Malloc'ed. */
  31.     int length;            /* Number of non-NULL chars. in command. */
  32.     char command[4];        /* Space for Tcl command to invoke.  Actual
  33.                  * size will be as large as necessary to
  34.                  * hold command.  This field must be the
  35.                  * last in the structure, so that it can
  36.                  * be larger than 4 bytes. */
  37. } TraceVarInfo;
  38.  
  39. /*
  40.  * Forward declarations for procedures defined in this file:
  41.  */
  42.  
  43. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  44.                 Tcl_Interp *interp, char *name1, char *name2,
  45.                 int flags));
  46.  
  47. /*
  48.  *----------------------------------------------------------------------
  49.  *
  50.  * Tcl_PwdCmd --
  51.  *
  52.  *    This procedure is invoked to process the "pwd" Tcl command.
  53.  *    See the user documentation for details on what it does.
  54.  *
  55.  * Results:
  56.  *    A standard Tcl result.
  57.  *
  58.  * Side effects:
  59.  *    See the user documentation.
  60.  *
  61.  *----------------------------------------------------------------------
  62.  */
  63.  
  64.     /* ARGSUSED */
  65. int
  66. Tcl_PwdCmd(dummy, interp, argc, argv)
  67.     ClientData dummy;            /* Not used. */
  68.     Tcl_Interp *interp;            /* Current interpreter. */
  69.     int argc;                /* Number of arguments. */
  70.     char **argv;            /* Argument strings. */
  71. {
  72.     char *dirName;
  73.  
  74.     if (argc != 1) {
  75.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  76.         argv[0], "\"", (char *) NULL);
  77.     return TCL_ERROR;
  78.     }
  79.  
  80.     dirName = TclGetCwd(interp);
  81.     if (dirName == NULL) {
  82.     return TCL_ERROR;
  83.     }
  84.     Tcl_SetResult(interp, dirName, TCL_VOLATILE);
  85.     return TCL_OK;
  86. }
  87.  
  88. /*
  89.  *----------------------------------------------------------------------
  90.  *
  91.  * Tcl_RegexpCmd --
  92.  *
  93.  *    This procedure is invoked to process the "regexp" Tcl command.
  94.  *    See the user documentation for details on what it does.
  95.  *
  96.  * Results:
  97.  *    A standard Tcl result.
  98.  *
  99.  * Side effects:
  100.  *    See the user documentation.
  101.  *
  102.  *----------------------------------------------------------------------
  103.  */
  104.  
  105.     /* ARGSUSED */
  106. int
  107. Tcl_RegexpCmd(dummy, interp, argc, argv)
  108.     ClientData dummy;            /* Not used. */
  109.     Tcl_Interp *interp;            /* Current interpreter. */
  110.     int argc;                /* Number of arguments. */
  111.     char **argv;            /* Argument strings. */
  112. {
  113.     int noCase = 0;
  114.     int indices = 0;
  115.     Tcl_RegExp regExpr;
  116.     char **argPtr, *string, *pattern, *start, *end;
  117.     int match = 0;            /* Initialization needed only to
  118.                      * prevent compiler warning. */
  119.     int i;
  120.     Tcl_DString stringDString, patternDString;
  121.  
  122.     if (argc < 3) {
  123.     wrongNumArgs:
  124.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  125.         " ?switches? exp string ?matchVar? ?subMatchVar ",
  126.         "subMatchVar ...?\"", (char *) NULL);
  127.     return TCL_ERROR;
  128.     }
  129.     argPtr = argv+1;
  130.     argc--;
  131.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  132.     if (strcmp(argPtr[0], "-indices") == 0) {
  133.         indices = 1;
  134.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  135.         noCase = 1;
  136.     } else if (strcmp(argPtr[0], "--") == 0) {
  137.         argPtr++;
  138.         argc--;
  139.         break;
  140.     } else {
  141.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  142.             "\": must be -indices, -nocase, or --", (char *) NULL);
  143.         return TCL_ERROR;
  144.     }
  145.     argPtr++;
  146.     argc--;
  147.     }
  148.     if (argc < 2) {
  149.     goto wrongNumArgs;
  150.     }
  151.  
  152.     /*
  153.      * Convert the string and pattern to lower case, if desired, and
  154.      * perform the matching operation.
  155.      */
  156.  
  157.     if (noCase) {
  158.     register char *p;
  159.  
  160.     Tcl_DStringInit(&patternDString);
  161.     Tcl_DStringAppend(&patternDString, argPtr[0], -1);
  162.     pattern = Tcl_DStringValue(&patternDString);
  163.     for (p = pattern; *p != 0; p++) {
  164.         if (isupper(UCHAR(*p))) {
  165.         *p = (char)tolower(UCHAR(*p));
  166.         }
  167.     }
  168.     Tcl_DStringInit(&stringDString);
  169.     Tcl_DStringAppend(&stringDString, argPtr[1], -1);
  170.     string = Tcl_DStringValue(&stringDString);
  171.     for (p = string; *p != 0; p++) {
  172.         if (isupper(UCHAR(*p))) {
  173.         *p = (char)tolower(UCHAR(*p));
  174.         }
  175.     }
  176.     } else {
  177.     pattern = argPtr[0];
  178.     string = argPtr[1];
  179.     }
  180.     regExpr = Tcl_RegExpCompile(interp, pattern);
  181.     if (regExpr != NULL) {
  182.     match = Tcl_RegExpExec(interp, regExpr, string, string);
  183.     }
  184.     if (noCase) {
  185.     Tcl_DStringFree(&stringDString);
  186.     Tcl_DStringFree(&patternDString);
  187.     }
  188.     if (regExpr == NULL) {
  189.     return TCL_ERROR;
  190.     }
  191.     if (match < 0) {
  192.     return TCL_ERROR;
  193.     }
  194.     if (!match) {
  195.     Tcl_SetResult(interp, "0", TCL_STATIC);
  196.     return TCL_OK;
  197.     }
  198.  
  199.     /*
  200.      * If additional variable names have been specified, return
  201.      * index information in those variables.
  202.      */
  203.  
  204.     argc -= 2;
  205.     for (i = 0; i < argc; i++) {
  206.     char *result, info[50];
  207.  
  208.     Tcl_RegExpRange(regExpr, i, &start, &end);
  209.     if (start == NULL) {
  210.         if (indices) {
  211.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  212.         } else {
  213.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  214.         }
  215.     } else {
  216.         if (indices) {
  217.         sprintf(info, "%d %d", (int)(start - string),
  218.             (int)(end - string - 1));
  219.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  220.         } else {
  221.         char savedChar, *first, *last;
  222.  
  223.         first = argPtr[1] + (start - string);
  224.         last = argPtr[1] + (end - string);
  225.         if (first == last) { /* don't modify argument */
  226.             result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  227.         } else {
  228.             savedChar = *last;
  229.             *last = 0;
  230.             result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  231.             *last = savedChar;
  232.         }
  233.         }
  234.     }
  235.     if (result == NULL) {
  236.         Tcl_AppendResult(interp, "couldn't set variable \"",
  237.             argPtr[i+2], "\"", (char *) NULL);
  238.         return TCL_ERROR;
  239.     }
  240.     }
  241.     Tcl_SetResult(interp, "1", TCL_STATIC);
  242.     return TCL_OK;
  243. }
  244.  
  245. /*
  246.  *----------------------------------------------------------------------
  247.  *
  248.  * Tcl_RegsubCmd --
  249.  *
  250.  *    This procedure is invoked to process the "regsub" Tcl command.
  251.  *    See the user documentation for details on what it does.
  252.  *
  253.  * Results:
  254.  *    A standard Tcl result.
  255.  *
  256.  * Side effects:
  257.  *    See the user documentation.
  258.  *
  259.  *----------------------------------------------------------------------
  260.  */
  261.  
  262.     /* ARGSUSED */
  263. int
  264. Tcl_RegsubCmd(dummy, interp, argc, argv)
  265.     ClientData dummy;            /* Not used. */
  266.     Tcl_Interp *interp;            /* Current interpreter. */
  267.     int argc;                /* Number of arguments. */
  268.     char **argv;            /* Argument strings. */
  269. {
  270.     int noCase = 0, all = 0;
  271.     Tcl_RegExp regExpr;
  272.     char *string, *pattern, *p, *firstChar, **argPtr;
  273.     int match, code, numMatches;
  274.     char *start, *end, *subStart, *subEnd;
  275.     register char *src, c;
  276.     Tcl_DString stringDString, patternDString, resultDString;
  277.  
  278.     if (argc < 5) {
  279.     wrongNumArgs:
  280.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  281.         " ?switches? exp string subSpec varName\"", (char *) NULL);
  282.     return TCL_ERROR;
  283.     }
  284.     argPtr = argv+1;
  285.     argc--;
  286.     while (argPtr[0][0] == '-') {
  287.     if (strcmp(argPtr[0], "-nocase") == 0) {
  288.         noCase = 1;
  289.     } else if (strcmp(argPtr[0], "-all") == 0) {
  290.         all = 1;
  291.     } else if (strcmp(argPtr[0], "--") == 0) {
  292.         argPtr++;
  293.         argc--;
  294.         break;
  295.     } else {
  296.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  297.             "\": must be -all, -nocase, or --", (char *) NULL);
  298.         return TCL_ERROR;
  299.     }
  300.     argPtr++;
  301.     argc--;
  302.     }
  303.     if (argc != 4) {
  304.     goto wrongNumArgs;
  305.     }
  306.  
  307.     /*
  308.      * Convert the string and pattern to lower case, if desired.
  309.      */
  310.  
  311.     if (noCase) {
  312.     Tcl_DStringInit(&patternDString);
  313.     Tcl_DStringAppend(&patternDString, argPtr[0], -1);
  314.     pattern = Tcl_DStringValue(&patternDString);
  315.     for (p = pattern; *p != 0; p++) {
  316.         if (isupper(UCHAR(*p))) {
  317.         *p = (char)tolower(UCHAR(*p));
  318.         }
  319.     }
  320.     Tcl_DStringInit(&stringDString);
  321.     Tcl_DStringAppend(&stringDString, argPtr[1], -1);
  322.     string = Tcl_DStringValue(&stringDString);
  323.     for (p = string; *p != 0; p++) {
  324.         if (isupper(UCHAR(*p))) {
  325.         *p = (char)tolower(UCHAR(*p));
  326.         }
  327.     }
  328.     } else {
  329.     pattern = argPtr[0];
  330.     string = argPtr[1];
  331.     }
  332.     Tcl_DStringInit(&resultDString);
  333.     regExpr = Tcl_RegExpCompile(interp, pattern);
  334.     if (regExpr == NULL) {
  335.     code = TCL_ERROR;
  336.     goto done;
  337.     }
  338.  
  339.     /*
  340.      * The following loop is to handle multiple matches within the
  341.      * same source string;  each iteration handles one match and its
  342.      * corresponding substitution.  If "-all" hasn't been specified
  343.      * then the loop body only gets executed once.
  344.      */
  345.  
  346.     numMatches = 0;
  347.     for (p = string; *p != 0; ) {
  348.     match = Tcl_RegExpExec(interp, regExpr, p, string);
  349.     if (match < 0) {
  350.         code = TCL_ERROR;
  351.         goto done;
  352.     }
  353.     if (!match) {
  354.         break;
  355.     }
  356.     numMatches += 1;
  357.  
  358.     /*
  359.      * Copy the portion of the source string before the match to the
  360.      * result variable.
  361.      */
  362.  
  363.     Tcl_RegExpRange(regExpr, 0, &start, &end);
  364.     Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
  365.     
  366.     /*
  367.      * Append the subSpec argument to the variable, making appropriate
  368.      * substitutions.  This code is a bit hairy because of the backslash
  369.      * conventions and because the code saves up ranges of characters in
  370.      * subSpec to reduce the number of calls to Tcl_SetVar.
  371.      */
  372.     
  373.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  374.         int index;
  375.     
  376.         if (c == '&') {
  377.         index = 0;
  378.         } else if (c == '\\') {
  379.         c = src[1];
  380.         if ((c >= '0') && (c <= '9')) {
  381.             index = c - '0';
  382.         } else if ((c == '\\') || (c == '&')) {
  383.             *src = c;
  384.             src[1] = 0;
  385.             Tcl_DStringAppend(&resultDString, firstChar, -1);
  386.             *src = '\\';
  387.             src[1] = c;
  388.             firstChar = src+2;
  389.             src++;
  390.             continue;
  391.         } else {
  392.             continue;
  393.         }
  394.         } else {
  395.         continue;
  396.         }
  397.         if (firstChar != src) {
  398.         c = *src;
  399.         *src = 0;
  400.         Tcl_DStringAppend(&resultDString, firstChar, -1);
  401.         *src = c;
  402.         }
  403.         Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
  404.         if ((subStart != NULL) && (subEnd != NULL)) {
  405.         char *first, *last, saved;
  406.     
  407.         first = argPtr[1] + (subStart - string);
  408.         last = argPtr[1] + (subEnd - string);
  409.         saved = *last;
  410.         *last = 0;
  411.         Tcl_DStringAppend(&resultDString, first, -1);
  412.         *last = saved;
  413.         }
  414.         if (*src == '\\') {
  415.         src++;
  416.         }
  417.         firstChar = src+1;
  418.     }
  419.     if (firstChar != src) {
  420.         Tcl_DStringAppend(&resultDString, firstChar, -1);
  421.     }
  422.     if (end == p) {
  423.  
  424.         /*
  425.          * Always consume at least one character of the input string
  426.          * in order to prevent infinite loops.
  427.          */
  428.  
  429.         Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
  430.         p = end + 1;
  431.     } else {
  432.         p = end;
  433.     }
  434.     if (!all) {
  435.         break;
  436.     }
  437.     }
  438.  
  439.     /*
  440.      * Copy the portion of the source string after the last match to the
  441.      * result variable.
  442.      */
  443.  
  444.     if ((*p != 0) || (numMatches == 0)) {
  445.     Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
  446.     }
  447.     if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
  448.          == NULL) {
  449.     Tcl_AppendResult(interp,
  450.         "couldn't set variable \"", argPtr[3], "\"",
  451.         (char *) NULL);
  452.     code = TCL_ERROR;
  453.     } else {
  454.     char buf[40];
  455.     
  456.     TclFormatInt(buf, numMatches);
  457.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  458.     code = TCL_OK;
  459.     }
  460.  
  461.     done:
  462.     if (noCase) {
  463.     Tcl_DStringFree(&stringDString);
  464.     Tcl_DStringFree(&patternDString);
  465.     }
  466.     Tcl_DStringFree(&resultDString);
  467.     return code;
  468. }
  469.  
  470. /*
  471.  *----------------------------------------------------------------------
  472.  *
  473.  * Tcl_RenameObjCmd --
  474.  *
  475.  *    This procedure is invoked to process the "rename" Tcl command.
  476.  *    See the user documentation for details on what it does.
  477.  *
  478.  * Results:
  479.  *    A standard Tcl object result.
  480.  *
  481.  * Side effects:
  482.  *    See the user documentation.
  483.  *
  484.  *----------------------------------------------------------------------
  485.  */
  486.  
  487.     /* ARGSUSED */
  488. int
  489. Tcl_RenameObjCmd(dummy, interp, objc, objv)
  490.     ClientData dummy;        /* Arbitrary value passed to the command. */
  491.     Tcl_Interp *interp;        /* Current interpreter. */
  492.     int objc;            /* Number of arguments. */
  493.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  494. {
  495.     char *oldName, *newName;
  496.     
  497.     if (objc != 3) {
  498.     Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
  499.     return TCL_ERROR;
  500.     }
  501.  
  502.     oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
  503.     newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  504.     return TclRenameCommand(interp, oldName, newName);
  505. }
  506.  
  507. /*
  508.  *----------------------------------------------------------------------
  509.  *
  510.  * Tcl_ReturnObjCmd --
  511.  *
  512.  *    This object-based procedure is invoked to process the "return" Tcl
  513.  *    command. See the user documentation for details on what it does.
  514.  *
  515.  * Results:
  516.  *    A standard Tcl object result.
  517.  *
  518.  * Side effects:
  519.  *    See the user documentation.
  520.  *
  521.  *----------------------------------------------------------------------
  522.  */
  523.  
  524.     /* ARGSUSED */
  525. int
  526. Tcl_ReturnObjCmd(dummy, interp, objc, objv)
  527.     ClientData dummy;        /* Not used. */
  528.     Tcl_Interp *interp;        /* Current interpreter. */
  529.     int objc;            /* Number of arguments. */
  530.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  531. {
  532.     Interp *iPtr = (Interp *) interp;
  533.     int optionLen, argLen, code, result;
  534.  
  535.     if (iPtr->errorInfo != NULL) {
  536.     ckfree(iPtr->errorInfo);
  537.     iPtr->errorInfo = NULL;
  538.     }
  539.     if (iPtr->errorCode != NULL) {
  540.     ckfree(iPtr->errorCode);
  541.     iPtr->errorCode = NULL;
  542.     }
  543.     code = TCL_OK;
  544.  
  545.    /*
  546.     * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
  547.     */
  548.     
  549.     for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
  550.     char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
  551.     char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
  552.         
  553.     if (strcmp(option, "-code") == 0) {
  554.         register int c = arg[0];
  555.         if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
  556.         code = TCL_OK;
  557.         } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
  558.         code = TCL_ERROR;
  559.         } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
  560.         code = TCL_RETURN;
  561.         } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
  562.         code = TCL_BREAK;
  563.         } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
  564.         code = TCL_CONTINUE;
  565.         } else {
  566.         result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
  567.                 &code);
  568.         if (result != TCL_OK) {
  569.             Tcl_ResetResult(interp);
  570.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  571.                 "bad completion code \"",
  572.                 Tcl_GetStringFromObj(objv[1], (int *) NULL),
  573.                 "\": must be ok, error, return, break, ",
  574.                 "continue, or an integer", (char *) NULL);
  575.             return result;
  576.         }
  577.         }
  578.     } else if (strcmp(option, "-errorinfo") == 0) {
  579.         iPtr->errorInfo =
  580.         (char *) ckalloc((unsigned) (strlen(arg) + 1));
  581.         strcpy(iPtr->errorInfo, arg);
  582.     } else if (strcmp(option, "-errorcode") == 0) {
  583.         iPtr->errorCode =
  584.         (char *) ckalloc((unsigned) (strlen(arg) + 1));
  585.         strcpy(iPtr->errorCode, arg);
  586.     } else {
  587.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  588.             "bad option \"", option,
  589.             "\": must be -code, -errorcode, or -errorinfo",
  590.             (char *) NULL);
  591.         return TCL_ERROR;
  592.     }
  593.     }
  594.     
  595.     if (objc == 1) {
  596.     /*
  597.      * Set the interpreter's object result. An inline version of
  598.      * Tcl_SetObjResult.
  599.      */
  600.  
  601.     Tcl_SetObjResult(interp, objv[0]);
  602.     }
  603.     iPtr->returnCode = code;
  604.     return TCL_RETURN;
  605. }
  606.  
  607. /*
  608.  *----------------------------------------------------------------------
  609.  *
  610.  * Tcl_ScanCmd --
  611.  *
  612.  *    This procedure is invoked to process the "scan" Tcl command.
  613.  *    See the user documentation for details on what it does.
  614.  *
  615.  * Results:
  616.  *    A standard Tcl result.
  617.  *
  618.  * Side effects:
  619.  *    See the user documentation.
  620.  *
  621.  *----------------------------------------------------------------------
  622.  */
  623.  
  624.     /* ARGSUSED */
  625. int
  626. Tcl_ScanCmd(dummy, interp, argc, argv)
  627.     ClientData dummy;            /* Not used. */
  628.     Tcl_Interp *interp;            /* Current interpreter. */
  629.     int argc;                /* Number of arguments. */
  630.     char **argv;            /* Argument strings. */
  631. {
  632. #   define MAX_FIELDS 20
  633.     typedef struct {
  634.     char fmt;            /* Format for field. */
  635.     int size;            /* How many bytes to allow for
  636.                      * field. */
  637.     char *location;            /* Where field will be stored. */
  638.     } Field;
  639.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  640.                      * format string. */
  641.     register Field *curField;
  642.     int numFields = 0;            /* Number of fields actually
  643.                      * specified. */
  644.     int suppress;            /* Current field is assignment-
  645.                      * suppressed. */
  646.     int totalSize = 0;            /* Number of bytes needed to store
  647.                      * all results combined. */
  648.     char *results;            /* Where scanned output goes.
  649.                      * Malloced; NULL means not allocated
  650.                      * yet. */
  651.     int numScanned;            /* sscanf's result. */
  652.     register char *fmt;
  653.     int i, widthSpecified, length, code;
  654.     char buf[40];
  655.  
  656.     /*
  657.      * The variables below are used to hold a copy of the format
  658.      * string, so that we can replace format specifiers like "%f"
  659.      * and "%F" with specifiers like "%lf"
  660.      */
  661.  
  662. #   define STATIC_SIZE 5
  663.     char copyBuf[STATIC_SIZE], *fmtCopy;
  664.     register char *dst;
  665.  
  666.     if (argc < 3) {
  667.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  668.         " string format ?varName varName ...?\"", (char *) NULL);
  669.     return TCL_ERROR;
  670.     }
  671.  
  672.     /*
  673.      * This procedure operates in four stages:
  674.      * 1. Scan the format string, collecting information about each field.
  675.      * 2. Allocate an array to hold all of the scanned fields.
  676.      * 3. Call sscanf to do all the dirty work, and have it store the
  677.      *    parsed fields in the array.
  678.      * 4. Pick off the fields from the array and assign them to variables.
  679.      */
  680.  
  681.     code = TCL_OK;
  682.     results = NULL;
  683.     length = strlen(argv[2]) * 2 + 1;
  684.     if (length < STATIC_SIZE) {
  685.     fmtCopy = copyBuf;
  686.     } else {
  687.     fmtCopy = (char *) ckalloc((unsigned) length);
  688.     }
  689.     dst = fmtCopy;
  690.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  691.     *dst = *fmt;
  692.     dst++;
  693.     if (*fmt != '%') {
  694.         continue;
  695.     }
  696.     fmt++;
  697.     if (*fmt == '%') {
  698.         *dst = *fmt;
  699.         dst++;
  700.         continue;
  701.     }
  702.     if (*fmt == '*') {
  703.         suppress = 1;
  704.         *dst = *fmt;
  705.         dst++;
  706.         fmt++;
  707.     } else {
  708.         suppress = 0;
  709.     }
  710.     widthSpecified = 0;
  711.     while (isdigit(UCHAR(*fmt))) {
  712.         widthSpecified = 1;
  713.         *dst = *fmt;
  714.         dst++;
  715.         fmt++;
  716.     }
  717.     if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
  718.         fmt++;
  719.     }
  720.     *dst = *fmt;
  721.     dst++;
  722.     if (suppress) {
  723.         continue;
  724.     }
  725.     if (numFields == MAX_FIELDS) {
  726.         Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
  727.         code = TCL_ERROR;
  728.         goto done;
  729.     }
  730.     curField = &fields[numFields];
  731.     numFields++;
  732.     switch (*fmt) {
  733.         case 'd':
  734.         case 'i':
  735.         case 'o':
  736.         case 'x':
  737.         curField->fmt = 'd';
  738.         curField->size = sizeof(int);
  739.         break;
  740.  
  741.         case 'u':
  742.         curField->fmt = 'u';
  743.         curField->size = sizeof(int);
  744.         break;
  745.  
  746.         case 's':
  747.         curField->fmt = 's';
  748.         curField->size = strlen(argv[1]) + 1;
  749.         break;
  750.  
  751.         case 'c':
  752.                 if (widthSpecified) {
  753.             Tcl_SetResult(interp,
  754.                     "field width may not be specified in %c conversion",
  755.                 TCL_STATIC);
  756.             code = TCL_ERROR;
  757.             goto done;
  758.                 }
  759.         curField->fmt = 'c';
  760.         curField->size = sizeof(int);
  761.         break;
  762.  
  763.         case 'e':
  764.         case 'f':
  765.         case 'g':
  766.         dst[-1] = 'l';
  767.         dst[0] = 'f';
  768.         dst++;
  769.         curField->fmt = 'f';
  770.         curField->size = sizeof(double);
  771.         break;
  772.  
  773.         case '[':
  774.         curField->fmt = 's';
  775.         curField->size = strlen(argv[1]) + 1;
  776.         do {
  777.             fmt++;
  778.             if (*fmt == 0) {
  779.             Tcl_SetResult(interp,
  780.                     "unmatched [ in format string", TCL_STATIC);
  781.             code = TCL_ERROR;
  782.             goto done;
  783.             }
  784.             *dst = *fmt;
  785.             dst++;
  786.         } while (*fmt != ']');
  787.         break;
  788.  
  789.         default:
  790.         {
  791.             char buf[50];
  792.  
  793.             sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
  794.             Tcl_SetResult(interp, buf, TCL_VOLATILE);
  795.             code = TCL_ERROR;
  796.             goto done;
  797.         }
  798.     }
  799.     curField->size = TCL_ALIGN(curField->size);
  800.     totalSize += curField->size;
  801.     }
  802.     *dst = 0;
  803.  
  804.     if (numFields != (argc-3)) {
  805.     Tcl_SetResult(interp,
  806.         "different numbers of variable names and field specifiers",
  807.         TCL_STATIC);
  808.     code = TCL_ERROR;
  809.     goto done;
  810.     }
  811.  
  812.     /*
  813.      * Step 2:
  814.      */
  815.  
  816.     results = (char *) ckalloc((unsigned) totalSize);
  817.     for (i = 0, totalSize = 0, curField = fields;
  818.         i < numFields; i++, curField++) {
  819.     curField->location = results + totalSize;
  820.     totalSize += curField->size;
  821.     }
  822.  
  823.     /*
  824.      * Fill in the remaining fields with NULL;  the only purpose of
  825.      * this is to keep some memory analyzers, like Purify, from
  826.      * complaining.
  827.      */
  828.  
  829.     for ( ; i < MAX_FIELDS; i++, curField++) {
  830.     curField->location = NULL;
  831.     }
  832.  
  833.     /*
  834.      * Step 3:
  835.      */
  836.  
  837.     numScanned = sscanf(argv[1], fmtCopy,
  838.         fields[0].location, fields[1].location, fields[2].location,
  839.         fields[3].location, fields[4].location, fields[5].location,
  840.         fields[6].location, fields[7].location, fields[8].location,
  841.         fields[9].location, fields[10].location, fields[11].location,
  842.         fields[12].location, fields[13].location, fields[14].location,
  843.         fields[15].location, fields[16].location, fields[17].location,
  844.         fields[18].location, fields[19].location);
  845.  
  846.     /*
  847.      * Step 4:
  848.      */
  849.  
  850.     if (numScanned < numFields) {
  851.     numFields = numScanned;
  852.     }
  853.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  854.     switch (curField->fmt) {
  855.         char string[TCL_DOUBLE_SPACE];
  856.  
  857.         case 'd':
  858.         TclFormatInt(string, *((int *) curField->location));
  859.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  860.             storeError:
  861.             Tcl_AppendResult(interp,
  862.                 "couldn't set variable \"", argv[i+3], "\"",
  863.                 (char *) NULL);
  864.             code = TCL_ERROR;
  865.             goto done;
  866.         }
  867.         break;
  868.  
  869.         case 'u':
  870.         sprintf(string, "%u", *((int *) curField->location));
  871.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  872.             goto storeError;
  873.         }
  874.         break;
  875.  
  876.         case 'c':
  877.         TclFormatInt(string, *((char *) curField->location) & 0xff);
  878.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  879.             goto storeError;
  880.         }
  881.         break;
  882.  
  883.         case 's':
  884.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  885.             == NULL) {
  886.             goto storeError;
  887.         }
  888.         break;
  889.  
  890.         case 'f':
  891.         Tcl_PrintDouble((Tcl_Interp *) NULL,
  892.             *((double *) curField->location), string);
  893.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  894.             goto storeError;
  895.         }
  896.         break;
  897.     }
  898.     }
  899.     TclFormatInt(buf, numScanned);
  900.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  901.     done:
  902.     if (results != NULL) {
  903.     ckfree(results);
  904.     }
  905.     if (fmtCopy != copyBuf) {
  906.     ckfree(fmtCopy);
  907.     }
  908.     return code;
  909. }
  910.  
  911. /*
  912.  *----------------------------------------------------------------------
  913.  *
  914.  * Tcl_SourceObjCmd --
  915.  *
  916.  *    This procedure is invoked to process the "source" Tcl command.
  917.  *    See the user documentation for details on what it does.
  918.  *
  919.  * Results:
  920.  *    A standard Tcl object result.
  921.  *
  922.  * Side effects:
  923.  *    See the user documentation.
  924.  *
  925.  *----------------------------------------------------------------------
  926.  */
  927.  
  928.     /* ARGSUSED */
  929. int
  930. Tcl_SourceObjCmd(dummy, interp, objc, objv)
  931.     ClientData dummy;        /* Not used. */
  932.     Tcl_Interp *interp;        /* Current interpreter. */
  933.     int objc;            /* Number of arguments. */
  934.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  935. {
  936.     char *bytes;
  937.     int result;
  938.     
  939.     if (objc != 2) {
  940.     Tcl_WrongNumArgs(interp, 1, objv, "fileName");
  941.     return TCL_ERROR;
  942.     }
  943.  
  944.     /*
  945.      * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
  946.      */
  947.  
  948.     bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
  949.     result = Tcl_EvalFile(interp, bytes);
  950.     return result;
  951. }
  952.  
  953. /*
  954.  *----------------------------------------------------------------------
  955.  *
  956.  * Tcl_SplitObjCmd --
  957.  *
  958.  *    This procedure is invoked to process the "split" Tcl command.
  959.  *    See the user documentation for details on what it does.
  960.  *
  961.  * Results:
  962.  *    A standard Tcl result.
  963.  *
  964.  * Side effects:
  965.  *    See the user documentation.
  966.  *
  967.  *----------------------------------------------------------------------
  968.  */
  969.  
  970.     /* ARGSUSED */
  971. int
  972. Tcl_SplitObjCmd(dummy, interp, objc, objv)
  973.     ClientData dummy;        /* Not used. */
  974.     Tcl_Interp *interp;        /* Current interpreter. */
  975.     int objc;            /* Number of arguments. */
  976.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  977. {
  978.     register char *p, *p2;
  979.     char *splitChars, *string, *elementStart;
  980.     int splitCharLen, stringLen, i, j;
  981.     Tcl_Obj *listPtr;
  982.  
  983.     if (objc == 2) {
  984.     splitChars = " \n\t\r";
  985.     splitCharLen = 4;
  986.     } else if (objc == 3) {
  987.     splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
  988.     } else {
  989.     Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
  990.     return TCL_ERROR;
  991.     }
  992.  
  993.     string = Tcl_GetStringFromObj(objv[1], &stringLen);
  994.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  995.     
  996.     /*
  997.      * Handle the special case of splitting on every character.
  998.      */
  999.  
  1000.     if (splitCharLen == 0) {
  1001.     for (i = 0, p = string;  i < stringLen;  i++, p++) {
  1002.         Tcl_ListObjAppendElement(interp, listPtr,
  1003.                     Tcl_NewStringObj(p, 1));
  1004.     }
  1005.     } else {
  1006.     /*
  1007.      * Normal case: split on any of a given set of characters.
  1008.      * Discard instances of the split characters.
  1009.      */
  1010.  
  1011.     for (i = 0, p = elementStart = string;  i < stringLen;  i++, p++) {
  1012.         for (j = 0, p2 = splitChars;  j < splitCharLen;  j++, p2++) {
  1013.         if (*p2 == *p) {
  1014.             Tcl_ListObjAppendElement(interp, listPtr,
  1015.                             Tcl_NewStringObj(elementStart, (p-elementStart)));
  1016.             elementStart = p+1;
  1017.             break;
  1018.         }
  1019.         }
  1020.     }
  1021.     if (p != string) {
  1022.         int remainingChars = stringLen - (elementStart-string);
  1023.         Tcl_ListObjAppendElement(interp, listPtr,
  1024.                     Tcl_NewStringObj(elementStart, remainingChars));
  1025.     }
  1026.     }
  1027.  
  1028.     Tcl_SetObjResult(interp, listPtr);
  1029.     return TCL_OK;
  1030. }
  1031.  
  1032. /*
  1033.  *----------------------------------------------------------------------
  1034.  *
  1035.  * Tcl_StringObjCmd --
  1036.  *
  1037.  *    This procedure is invoked to process the "string" Tcl command.
  1038.  *    See the user documentation for details on what it does.
  1039.  *
  1040.  * Results:
  1041.  *    A standard Tcl result.
  1042.  *
  1043.  * Side effects:
  1044.  *    See the user documentation.
  1045.  *
  1046.  *----------------------------------------------------------------------
  1047.  */
  1048.  
  1049.     /* ARGSUSED */
  1050. int
  1051. Tcl_StringObjCmd(dummy, interp, objc, objv)
  1052.     ClientData dummy;        /* Not used. */
  1053.     Tcl_Interp *interp;        /* Current interpreter. */
  1054.     int objc;            /* Number of arguments. */
  1055.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1056. {
  1057.     int index, first, left, right;
  1058.     Tcl_Obj *resultPtr;
  1059.     char *string1, *string2;
  1060.     int length1, length2;
  1061.     static char *options[] = {
  1062.     "compare",    "first",    "index",    "last",
  1063.     "length",    "match",    "range",    "tolower",
  1064.     "toupper",    "trim",        "trimleft",    "trimright",
  1065.     "wordend",    "wordstart",    NULL
  1066.     };
  1067.     enum options {
  1068.     STR_COMPARE,    STR_FIRST,    STR_INDEX,    STR_LAST,
  1069.     STR_LENGTH,    STR_MATCH,    STR_RANGE,    STR_TOLOWER,
  1070.     STR_TOUPPER,    STR_TRIM,    STR_TRIMLEFT,    STR_TRIMRIGHT,
  1071.     STR_WORDEND,    STR_WORDSTART
  1072.     };      
  1073.         
  1074.     if (objc < 2) {
  1075.         Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  1076.     return TCL_ERROR;
  1077.     }
  1078.     
  1079.     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
  1080.         &index) != TCL_OK) {
  1081.     return TCL_ERROR;
  1082.     }
  1083.  
  1084.     resultPtr = Tcl_GetObjResult(interp);
  1085.     switch ((enum options) index) {
  1086.     case STR_COMPARE: {
  1087.         int match, length;
  1088.  
  1089.         if (objc != 4) {
  1090.             Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
  1091.         return TCL_ERROR;
  1092.         }
  1093.  
  1094.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1095.         string2 = Tcl_GetStringFromObj(objv[3], &length2);
  1096.  
  1097.         length = (length1 < length2) ? length1 : length2;
  1098.         match = memcmp(string1, string2, (unsigned) length);
  1099.         if (match == 0) {
  1100.             match = length1 - length2;
  1101.         }
  1102.         Tcl_SetIntObj(resultPtr, (match > 0) ? 1 : (match < 0) ? -1 : 0);
  1103.         break;
  1104.     }
  1105.     case STR_FIRST: {
  1106.         first = 1;
  1107.         goto firstlast;
  1108.     }
  1109.     case STR_INDEX: {
  1110.         int index;
  1111.  
  1112.         if (objc != 4) {
  1113.             Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
  1114.         return TCL_ERROR;
  1115.         }
  1116.  
  1117.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1118.         if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
  1119.         return TCL_ERROR;
  1120.         }
  1121.         if ((index >= 0) && (index < length1)) {
  1122.             Tcl_SetStringObj(resultPtr, string1 + index, 1);
  1123.         }
  1124.         break;
  1125.     }
  1126.     case STR_LAST: {
  1127.         char *p, *end;
  1128.         int match;
  1129.  
  1130.         first = 0;
  1131.  
  1132.         firstlast:
  1133.         if (objc != 4) {
  1134.             Tcl_WrongNumArgs(interp, 2, objv, "string1 string2");
  1135.         return TCL_ERROR;
  1136.         }
  1137.  
  1138.         match = -1;
  1139.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1140.         string2 = Tcl_GetStringFromObj(objv[3], &length2);
  1141.         if (length1 > 0) {
  1142.         end = string2 + length2 - length1 + 1;
  1143.         for (p = string2; p < end; p++) {
  1144.             if (memcmp(string1, p, (unsigned) length1) == 0) {
  1145.             match = p - string2;
  1146.             if (first) {
  1147.                 break;
  1148.             }
  1149.             }
  1150.         }
  1151.         }
  1152.         Tcl_SetIntObj(resultPtr, match);
  1153.         break;
  1154.     }
  1155.     case STR_LENGTH: {
  1156.         if (objc != 3) {
  1157.             Tcl_WrongNumArgs(interp, 2, objv, "string");
  1158.         return TCL_ERROR;
  1159.         }
  1160.  
  1161.         (void) Tcl_GetStringFromObj(objv[2], &length1);
  1162.         Tcl_SetIntObj(resultPtr, length1);
  1163.         break;
  1164.     }
  1165.     case STR_MATCH: {
  1166.         if (objc != 4) {
  1167.             Tcl_WrongNumArgs(interp, 2, objv, "pattern string");
  1168.         return TCL_ERROR;
  1169.         }
  1170.  
  1171.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1172.         string2 = Tcl_GetStringFromObj(objv[3], &length2);
  1173.         Tcl_SetBooleanObj(resultPtr, Tcl_StringMatch(string2, string1));
  1174.         break;
  1175.     }
  1176.     case STR_RANGE: {
  1177.         int first, last;
  1178.  
  1179.         if (objc != 5) {
  1180.             Tcl_WrongNumArgs(interp, 2, objv, "string first last");
  1181.         return TCL_ERROR;
  1182.         }
  1183.  
  1184.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1185.         if (TclGetIntForIndex(interp, objv[3], length1 - 1,
  1186.             &first) != TCL_OK) {
  1187.         return TCL_ERROR;
  1188.         }
  1189.         if (TclGetIntForIndex(interp, objv[4], length1 - 1,
  1190.             &last) != TCL_OK) {
  1191.         return TCL_ERROR;
  1192.         }
  1193.         if (first < 0) {
  1194.         first = 0;
  1195.         }
  1196.         if (last >= length1 - 1) {
  1197.         last = length1 - 1;
  1198.         }
  1199.         if (last >= first) {
  1200.             Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
  1201.         }
  1202.         break;
  1203.     }
  1204.     case STR_TOLOWER: {
  1205.         char *p, *end;
  1206.  
  1207.         if (objc != 3) {
  1208.             Tcl_WrongNumArgs(interp, 2, objv, "string");
  1209.         return TCL_ERROR;
  1210.         }
  1211.  
  1212.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1213.  
  1214.         /*
  1215.          * Since I know resultPtr is not a shared object, I can reach
  1216.          * in and diddle the bytes in its string rep to convert them in
  1217.          * place to lower case.
  1218.          */
  1219.  
  1220.         Tcl_SetStringObj(resultPtr, string1, length1);
  1221.         string1 = Tcl_GetStringFromObj(resultPtr, &length1);
  1222.         end = string1 + length1;
  1223.         for (p = string1; p < end; p++) {
  1224.         if (isupper(UCHAR(*p))) {
  1225.             *p = (char) tolower(UCHAR(*p));
  1226.         }
  1227.         }
  1228.         break;
  1229.     }
  1230.     case STR_TOUPPER: {
  1231.         char *p, *end;
  1232.  
  1233.         if (objc != 3) {
  1234.             Tcl_WrongNumArgs(interp, 2, objv, "string");
  1235.         return TCL_ERROR;
  1236.         }
  1237.  
  1238.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1239.  
  1240.         /*
  1241.          * Since I know resultPtr is not a shared object, I can reach
  1242.          * in and diddle the bytes in its string rep to convert them in
  1243.          * place to upper case.
  1244.          */
  1245.  
  1246.         Tcl_SetStringObj(resultPtr, string1, length1);
  1247.         string1 = Tcl_GetStringFromObj(resultPtr, &length1);
  1248.         end = string1 + length1;
  1249.         for (p = string1; p < end; p++) {
  1250.         if (islower(UCHAR(*p))) {
  1251.             *p = (char) toupper(UCHAR(*p));
  1252.         }
  1253.         }
  1254.         break;
  1255.     }
  1256.     case STR_TRIM: {
  1257.         char ch;
  1258.         char *p, *end, *check, *checkEnd;
  1259.  
  1260.         left = 1;
  1261.         right = 1;
  1262.  
  1263.         trim:
  1264.         if (objc == 4) {
  1265.         string2 = Tcl_GetStringFromObj(objv[3], &length2);
  1266.         } else if (objc == 3) {
  1267.         string2 = " \t\n\r";
  1268.         length2 = strlen(string2);
  1269.         } else {
  1270.             Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
  1271.         return TCL_ERROR;
  1272.         }
  1273.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1274.         checkEnd = string2 + length2;
  1275.  
  1276.         if (left) {
  1277.         end = string1 + length1;
  1278.         for (p = string1; p < end; p++) {
  1279.             ch = *p;
  1280.             for (check = string2; ; check++) {
  1281.             if (check >= checkEnd) {
  1282.                 p = end;
  1283.                 break;
  1284.             }
  1285.             if (ch == *check) {
  1286.                 length1--;
  1287.                 string1++;
  1288.                 break;
  1289.             }
  1290.             }
  1291.         }
  1292.         }
  1293.         if (right) {
  1294.             end = string1;
  1295.         for (p = string1 + length1; p > end; ) {
  1296.             p--;
  1297.             ch = *p;
  1298.             for (check = string2; ; check++) {
  1299.                 if (check >= checkEnd) {
  1300.                 p = end;
  1301.                 break;
  1302.             }
  1303.             if (ch == *check) {
  1304.                 length1--;
  1305.                 break;
  1306.             }
  1307.             }
  1308.         }
  1309.         }
  1310.         Tcl_SetStringObj(resultPtr, string1, length1);
  1311.         break;
  1312.     }
  1313.     case STR_TRIMLEFT: {
  1314.         left = 1;
  1315.         right = 0;
  1316.         goto trim;
  1317.     }
  1318.     case STR_TRIMRIGHT: {
  1319.         left = 0;
  1320.         right = 1;
  1321.         goto trim;
  1322.     }
  1323.     case STR_WORDEND: {
  1324.         int cur, c;
  1325.         
  1326.         if (objc != 4) {
  1327.             Tcl_WrongNumArgs(interp, 2, objv, "string index");
  1328.         return TCL_ERROR;
  1329.         }
  1330.  
  1331.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1332.         if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
  1333.             return TCL_ERROR;
  1334.         }
  1335.         if (index < 0) {
  1336.         index = 0;
  1337.         }
  1338.         cur = length1;
  1339.         if (index < length1) {
  1340.         for (cur = index; cur < length1; cur++) {
  1341.             c = UCHAR(string1[cur]);
  1342.             if (!isalnum(c) && (c != '_')) {
  1343.             break;
  1344.             }
  1345.         }
  1346.         if (cur == index) {
  1347.             cur = index + 1;
  1348.         }
  1349.         }
  1350.         Tcl_SetIntObj(resultPtr, cur);
  1351.         break;
  1352.     }
  1353.     case STR_WORDSTART: {
  1354.         int cur, c;
  1355.         
  1356.         if (objc != 4) {
  1357.             Tcl_WrongNumArgs(interp, 2, objv, "string index");
  1358.         return TCL_ERROR;
  1359.         }
  1360.  
  1361.         string1 = Tcl_GetStringFromObj(objv[2], &length1);
  1362.         if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
  1363.         return TCL_ERROR;
  1364.         }
  1365.         if (index >= length1) {
  1366.         index = length1 - 1;
  1367.         }
  1368.         cur = 0;
  1369.         if (index > 0) {
  1370.             for (cur = index; cur >= 0; cur--) {
  1371.             c = UCHAR(string1[cur]);
  1372.             if (!isalnum(c) && (c != '_')) {
  1373.             break;
  1374.             }
  1375.         }
  1376.         if (cur != index) {
  1377.             cur += 1;
  1378.         }
  1379.         }
  1380.         Tcl_SetIntObj(resultPtr, cur);
  1381.         break;
  1382.     }
  1383.     }
  1384.     return TCL_OK;
  1385. }
  1386.  
  1387. /*
  1388.  *----------------------------------------------------------------------
  1389.  *
  1390.  * Tcl_SubstCmd --
  1391.  *
  1392.  *    This procedure is invoked to process the "subst" Tcl command.
  1393.  *    See the user documentation for details on what it does.  This
  1394.  *    command is an almost direct copy of an implementation by
  1395.  *    Andrew Payne.
  1396.  *
  1397.  * Results:
  1398.  *    A standard Tcl result.
  1399.  *
  1400.  * Side effects:
  1401.  *    See the user documentation.
  1402.  *
  1403.  *----------------------------------------------------------------------
  1404.  */
  1405.  
  1406.     /* ARGSUSED */
  1407. int
  1408. Tcl_SubstCmd(dummy, interp, argc, argv)
  1409.     ClientData dummy;            /* Not used. */
  1410.     Tcl_Interp *interp;            /* Current interpreter. */
  1411.     int argc;                /* Number of arguments. */
  1412.     char **argv;            /* Argument strings. */
  1413. {
  1414.     Interp *iPtr = (Interp *) interp;
  1415.     Tcl_DString result;
  1416.     char *p, *old, *value;
  1417.     int code, count, doVars, doCmds, doBackslashes, i;
  1418.     size_t length;
  1419.     char c;
  1420.  
  1421.     /*
  1422.      * Parse command-line options.
  1423.      */
  1424.  
  1425.     doVars = doCmds = doBackslashes = 1;
  1426.     for (i = 1; i < (argc-1); i++) {
  1427.     p = argv[i];
  1428.     if (*p != '-') {
  1429.         break;
  1430.     }
  1431.     length = strlen(p);
  1432.     if (length < 4) {
  1433.         badSwitch:
  1434.         Tcl_AppendResult(interp, "bad switch \"", p,
  1435.             "\": must be -nobackslashes, -nocommands, ",
  1436.             "or -novariables", (char *) NULL);
  1437.         return TCL_ERROR;
  1438.     }
  1439.     if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
  1440.         doBackslashes = 0;
  1441.     } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
  1442.         doCmds = 0;
  1443.     } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
  1444.         doVars = 0;
  1445.     } else {
  1446.         goto badSwitch;
  1447.     }
  1448.     }
  1449.     if (i != (argc-1)) {
  1450.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1451.         " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
  1452.         (char *) NULL);
  1453.     return TCL_ERROR;
  1454.     }
  1455.  
  1456.     /*
  1457.      * Scan through the string one character at a time, performing
  1458.      * command, variable, and backslash substitutions.
  1459.      */
  1460.  
  1461.     Tcl_DStringInit(&result);
  1462.     old = p = argv[i];
  1463.     while (*p != 0) {
  1464.     switch (*p) {
  1465.         case '\\':
  1466.         if (doBackslashes) {
  1467.             if (p != old) {
  1468.             Tcl_DStringAppend(&result, old, p-old);
  1469.             }
  1470.             c = Tcl_Backslash(p, &count);
  1471.             Tcl_DStringAppend(&result, &c, 1);
  1472.             p += count;
  1473.             old = p;
  1474.         } else {
  1475.             p++;
  1476.         }
  1477.         break;
  1478.  
  1479.         case '$':
  1480.         if (doVars) {
  1481.             if (p != old) {
  1482.             Tcl_DStringAppend(&result, old, p-old);
  1483.             }
  1484.             value = Tcl_ParseVar(interp, p, &p);
  1485.             if (value == NULL) {
  1486.             Tcl_DStringFree(&result);
  1487.             return TCL_ERROR;
  1488.             }
  1489.             Tcl_DStringAppend(&result, value, -1);
  1490.             old = p;
  1491.         } else {
  1492.             p++;
  1493.         }
  1494.         break;
  1495.  
  1496.         case '[':
  1497.         if (doCmds) {
  1498.             if (p != old) {
  1499.             Tcl_DStringAppend(&result, old, p-old);
  1500.             }
  1501.             iPtr->evalFlags = TCL_BRACKET_TERM;
  1502.             code = Tcl_Eval(interp, p+1);
  1503.             if (code == TCL_ERROR) {
  1504.             Tcl_DStringFree(&result);
  1505.             return code;
  1506.             }
  1507.             old = p = (p+1 + iPtr->termOffset+1);
  1508.             Tcl_DStringAppend(&result, iPtr->result, -1);
  1509.             Tcl_ResetResult(interp);
  1510.         } else {
  1511.             p++;
  1512.         }
  1513.         break;
  1514.  
  1515.         default:
  1516.         p++;
  1517.         break;
  1518.     }
  1519.     }
  1520.     if (p != old) {
  1521.     Tcl_DStringAppend(&result, old, p-old);
  1522.     }
  1523.     Tcl_DStringResult(interp, &result);
  1524.     return TCL_OK;
  1525. }
  1526.  
  1527. /*
  1528.  *----------------------------------------------------------------------
  1529.  *
  1530.  * Tcl_SwitchObjCmd --
  1531.  *
  1532.  *    This object-based procedure is invoked to process the "switch" Tcl
  1533.  *    command. See the user documentation for details on what it does.
  1534.  *
  1535.  * Results:
  1536.  *    A standard Tcl object result.
  1537.  *
  1538.  * Side effects:
  1539.  *    See the user documentation.
  1540.  *
  1541.  *----------------------------------------------------------------------
  1542.  */
  1543.  
  1544.     /* ARGSUSED */
  1545. int
  1546. Tcl_SwitchObjCmd(dummy, interp, objc, objv)
  1547.     ClientData dummy;        /* Not used. */
  1548.     Tcl_Interp *interp;        /* Current interpreter. */
  1549.     int objc;            /* Number of arguments. */
  1550.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1551. {
  1552. #define EXACT    0
  1553. #define GLOB    1
  1554. #define REGEXP    2
  1555.     int switchObjc, index;
  1556.     Tcl_Obj *CONST *switchObjv;
  1557.     Tcl_Obj *patternObj, *bodyObj;
  1558.     char *string, *pattern, *body;
  1559.     int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
  1560.     static char *switches[] =
  1561.         {"-exact", "-glob", "-regexp", "--", (char *) NULL};
  1562.  
  1563.     switchObjc = objc-1;
  1564.     switchObjv = objv+1;
  1565.     mode = EXACT;
  1566.     
  1567.     string = Tcl_GetStringFromObj(switchObjv[0], &length);
  1568.     while ((switchObjc > 0) && (*string == '-')) {
  1569.     if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
  1570.         "option", 0, &index) != TCL_OK) {
  1571.         return TCL_ERROR;
  1572.     }
  1573.     switch (index) {
  1574.         case 0:            /* -exact */
  1575.         mode = EXACT;
  1576.         break;
  1577.         case 1:            /* -glob */
  1578.         mode = GLOB;
  1579.         break;
  1580.         case 2:            /* -regexp */
  1581.         mode = REGEXP;
  1582.         break;
  1583.         case 3:            /* -- */
  1584.         switchObjc--;
  1585.         switchObjv++;
  1586.         goto doneWithSwitches;
  1587.     }
  1588.     switchObjc--;
  1589.     switchObjv++;
  1590.     string = Tcl_GetStringFromObj(switchObjv[0], &length);
  1591.     }
  1592.  
  1593.     doneWithSwitches:
  1594.     if (switchObjc < 2) {
  1595.     Tcl_WrongNumArgs(interp, 1, objv,
  1596.         "?switches? string pattern body ... ?default body?");
  1597.     return TCL_ERROR;
  1598.     }
  1599.     
  1600.     string = Tcl_GetStringFromObj(switchObjv[0], &length);
  1601.     switchObjc--;
  1602.     switchObjv++;
  1603.  
  1604.     /*
  1605.      * If all of the pattern/command pairs are lumped into a single
  1606.      * argument, split them out again.
  1607.      */
  1608.  
  1609.     splitObjs = 0;
  1610.     if (switchObjc == 1) {
  1611.     code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
  1612.     if (code != TCL_OK) {
  1613.         return code;
  1614.     }
  1615.     splitObjs = 1;
  1616.     }
  1617.  
  1618.     for (i = 0;  i < switchObjc;  i += 2) {
  1619.     if (i == (switchObjc-1)) {
  1620.         Tcl_ResetResult(interp);
  1621.         Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1622.                 "extra switch pattern with no body", -1);
  1623.         code = TCL_ERROR;
  1624.         goto done;
  1625.     }
  1626.  
  1627.     /*
  1628.      * See if the pattern matches the string.
  1629.      */
  1630.  
  1631.     if (splitObjs) {
  1632.         code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
  1633.         if (code != TCL_OK) {
  1634.         return code;
  1635.         }
  1636.         pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
  1637.     } else {
  1638.         pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
  1639.     }
  1640.  
  1641.     matched = 0;
  1642.     if ((*pattern == 'd') && (i == switchObjc-2)
  1643.         && (strcmp(pattern, "default") == 0)) {
  1644.         matched = 1;
  1645.     } else {
  1646.         /*
  1647.          * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
  1648.          */
  1649.         switch (mode) {
  1650.         case EXACT:
  1651.             matched = (strcmp(string, pattern) == 0);
  1652.             break;
  1653.         case GLOB:
  1654.             matched = Tcl_StringMatch(string, pattern);
  1655.             break;
  1656.         case REGEXP:
  1657.             matched = Tcl_RegExpMatch(interp, string, pattern);
  1658.             if (matched < 0) {
  1659.             code = TCL_ERROR;
  1660.             goto done;
  1661.             }
  1662.             break;
  1663.         }
  1664.     }
  1665.     if (!matched) {
  1666.         continue;
  1667.     }
  1668.  
  1669.     /*
  1670.      * We've got a match. Find a body to execute, skipping bodies
  1671.      * that are "-".
  1672.      */
  1673.  
  1674.     for (bodyIdx = i+1;  ;  bodyIdx += 2) {
  1675.         if (bodyIdx >= switchObjc) {
  1676.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1677.             "no body specified for pattern \"", pattern,
  1678.             "\"", (char *) NULL);
  1679.         code = TCL_ERROR;
  1680.         goto done;
  1681.         }
  1682.         
  1683.         if (splitObjs) {
  1684.         code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
  1685.                 &bodyObj);
  1686.         if (code != TCL_OK) {
  1687.             return code;
  1688.         }
  1689.         } else {
  1690.         bodyObj = switchObjv[bodyIdx];
  1691.         }
  1692.         /*
  1693.          * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
  1694.          */
  1695.         body = Tcl_GetStringFromObj(bodyObj, &length);
  1696.         if ((length != 1) || (body[0] != '-')) {
  1697.         break;
  1698.         }
  1699.     }
  1700.     code = Tcl_EvalObj(interp, bodyObj);
  1701.     if (code == TCL_ERROR) {
  1702.         char msg[100];
  1703.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", pattern,
  1704.             interp->errorLine);
  1705.         Tcl_AddObjErrorInfo(interp, msg, -1);
  1706.     }
  1707.     goto done;
  1708.     }
  1709.  
  1710.     /*
  1711.      * Nothing matched:  return nothing.
  1712.      */
  1713.  
  1714.     code = TCL_OK;
  1715.  
  1716.     done:
  1717.     return code;
  1718. #undef EXACT
  1719. #undef GLOB
  1720. #undef REGEXP
  1721. }
  1722.  
  1723. /*
  1724.  *----------------------------------------------------------------------
  1725.  *
  1726.  * Tcl_TimeObjCmd --
  1727.  *
  1728.  *    This object-based procedure is invoked to process the "time" Tcl
  1729.  *    command.  See the user documentation for details on what it does.
  1730.  *
  1731.  * Results:
  1732.  *    A standard Tcl object result.
  1733.  *
  1734.  * Side effects:
  1735.  *    See the user documentation.
  1736.  *
  1737.  *----------------------------------------------------------------------
  1738.  */
  1739.  
  1740.     /* ARGSUSED */
  1741. int
  1742. Tcl_TimeObjCmd(dummy, interp, objc, objv)
  1743.     ClientData dummy;        /* Not used. */
  1744.     Tcl_Interp *interp;        /* Current interpreter. */
  1745.     int objc;            /* Number of arguments. */
  1746.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1747. {
  1748.     register Tcl_Obj *objPtr;
  1749.     register int i, result;
  1750.     int count;
  1751.     double totalMicroSec;
  1752.     Tcl_Time start, stop;
  1753.     char buf[100];
  1754.  
  1755.     if (objc == 2) {
  1756.     count = 1;
  1757.     } else if (objc == 3) {
  1758.     result = Tcl_GetIntFromObj(interp, objv[2], &count);
  1759.     if (result != TCL_OK) {
  1760.         return result;
  1761.     }
  1762.     } else {
  1763.     Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
  1764.     return TCL_ERROR;
  1765.     }
  1766.     
  1767.     objPtr = objv[1];
  1768.     i = count;
  1769.     TclpGetTime(&start);
  1770.     while (i-- > 0) {
  1771.     result = Tcl_EvalObj(interp, objPtr);
  1772.     if (result != TCL_OK) {
  1773.         return result;
  1774.     }
  1775.     }
  1776.     TclpGetTime(&stop);
  1777.     
  1778.     totalMicroSec =
  1779.     (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  1780.     sprintf(buf, "%.0f microseconds per iteration",
  1781.     ((count <= 0) ? 0 : totalMicroSec/count));
  1782.     Tcl_ResetResult(interp);
  1783.     Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  1784.     return TCL_OK;
  1785. }
  1786.  
  1787. /*
  1788.  *----------------------------------------------------------------------
  1789.  *
  1790.  * Tcl_TraceCmd --
  1791.  *
  1792.  *    This procedure is invoked to process the "trace" Tcl command.
  1793.  *    See the user documentation for details on what it does.
  1794.  *
  1795.  * Results:
  1796.  *    A standard Tcl result.
  1797.  *
  1798.  * Side effects:
  1799.  *    See the user documentation.
  1800.  *
  1801.  *----------------------------------------------------------------------
  1802.  */
  1803.  
  1804.     /* ARGSUSED */
  1805. int
  1806. Tcl_TraceCmd(dummy, interp, argc, argv)
  1807.     ClientData dummy;            /* Not used. */
  1808.     Tcl_Interp *interp;            /* Current interpreter. */
  1809.     int argc;                /* Number of arguments. */
  1810.     char **argv;            /* Argument strings. */
  1811. {
  1812.     int c;
  1813.     size_t length;
  1814.  
  1815.     if (argc < 2) {
  1816.     Tcl_AppendResult(interp, "too few args: should be \"",
  1817.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1818.     return TCL_ERROR;
  1819.     }
  1820.     c = argv[1][1];
  1821.     length = strlen(argv[1]);
  1822.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1823.         && (length >= 2)) {
  1824.     char *p;
  1825.     int flags, length;
  1826.     TraceVarInfo *tvarPtr;
  1827.  
  1828.     if (argc != 5) {
  1829.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1830.             argv[0], " variable name ops command\"", (char *) NULL);
  1831.         return TCL_ERROR;
  1832.     }
  1833.  
  1834.     flags = 0;
  1835.     for (p = argv[3] ; *p != 0; p++) {
  1836.         if (*p == 'r') {
  1837.         flags |= TCL_TRACE_READS;
  1838.         } else if (*p == 'w') {
  1839.         flags |= TCL_TRACE_WRITES;
  1840.         } else if (*p == 'u') {
  1841.         flags |= TCL_TRACE_UNSETS;
  1842.         } else {
  1843.         goto badOps;
  1844.         }
  1845.     }
  1846.     if (flags == 0) {
  1847.         goto badOps;
  1848.     }
  1849.  
  1850.     length = strlen(argv[4]);
  1851.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1852.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1853.     tvarPtr->flags = flags;
  1854.     tvarPtr->errMsg = NULL;
  1855.     tvarPtr->length = length;
  1856.     flags |= TCL_TRACE_UNSETS;
  1857.     strcpy(tvarPtr->command, argv[4]);
  1858.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1859.         (ClientData) tvarPtr) != TCL_OK) {
  1860.         ckfree((char *) tvarPtr);
  1861.         return TCL_ERROR;
  1862.     }
  1863.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1864.         && (length >= 2)) == 0) {
  1865.     char *p;
  1866.     int flags, length;
  1867.     TraceVarInfo *tvarPtr;
  1868.     ClientData clientData;
  1869.  
  1870.     if (argc != 5) {
  1871.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1872.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1873.         return TCL_ERROR;
  1874.     }
  1875.  
  1876.     flags = 0;
  1877.     for (p = argv[3] ; *p != 0; p++) {
  1878.         if (*p == 'r') {
  1879.         flags |= TCL_TRACE_READS;
  1880.         } else if (*p == 'w') {
  1881.         flags |= TCL_TRACE_WRITES;
  1882.         } else if (*p == 'u') {
  1883.         flags |= TCL_TRACE_UNSETS;
  1884.         } else {
  1885.         goto badOps;
  1886.         }
  1887.     }
  1888.     if (flags == 0) {
  1889.         goto badOps;
  1890.     }
  1891.  
  1892.     /*
  1893.      * Search through all of our traces on this variable to
  1894.      * see if there's one with the given command.  If so, then
  1895.      * delete the first one that matches.
  1896.      */
  1897.  
  1898.     length = strlen(argv[4]);
  1899.     clientData = 0;
  1900.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1901.         TraceVarProc, clientData)) != 0) {
  1902.         tvarPtr = (TraceVarInfo *) clientData;
  1903.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1904.             && (strncmp(argv[4], tvarPtr->command,
  1905.             (size_t) length) == 0)) {
  1906.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1907.             TraceVarProc, clientData);
  1908.         if (tvarPtr->errMsg != NULL) {
  1909.             ckfree(tvarPtr->errMsg);
  1910.         }
  1911.         ckfree((char *) tvarPtr);
  1912.         break;
  1913.         }
  1914.     }
  1915.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1916.         && (length >= 2)) {
  1917.     ClientData clientData;
  1918.     char ops[4], *p;
  1919.     char *prefix = "{";
  1920.  
  1921.     if (argc != 3) {
  1922.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1923.             argv[0], " vinfo name\"", (char *) NULL);
  1924.         return TCL_ERROR;
  1925.     }
  1926.     clientData = 0;
  1927.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1928.         TraceVarProc, clientData)) != 0) {
  1929.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1930.         p = ops;
  1931.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1932.         *p = 'r';
  1933.         p++;
  1934.         }
  1935.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1936.         *p = 'w';
  1937.         p++;
  1938.         }
  1939.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1940.         *p = 'u';
  1941.         p++;
  1942.         }
  1943.         *p = '\0';
  1944.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1945.         Tcl_AppendElement(interp, ops);
  1946.         Tcl_AppendElement(interp, tvarPtr->command);
  1947.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1948.         prefix = " {";
  1949.     }
  1950.     } else {
  1951.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1952.         "\": should be variable, vdelete, or vinfo",
  1953.         (char *) NULL);
  1954.     return TCL_ERROR;
  1955.     }
  1956.     return TCL_OK;
  1957.  
  1958.     badOps:
  1959.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1960.         "\": should be one or more of rwu", (char *) NULL);
  1961.     return TCL_ERROR;
  1962. }
  1963.  
  1964. /*
  1965.  *----------------------------------------------------------------------
  1966.  *
  1967.  * TraceVarProc --
  1968.  *
  1969.  *    This procedure is called to handle variable accesses that have
  1970.  *    been traced using the "trace" command.
  1971.  *
  1972.  * Results:
  1973.  *    Normally returns NULL.  If the trace command returns an error,
  1974.  *    then this procedure returns an error string.
  1975.  *
  1976.  * Side effects:
  1977.  *    Depends on the command associated with the trace.
  1978.  *
  1979.  *----------------------------------------------------------------------
  1980.  */
  1981.  
  1982.     /* ARGSUSED */
  1983. static char *
  1984. TraceVarProc(clientData, interp, name1, name2, flags)
  1985.     ClientData clientData;    /* Information about the variable trace. */
  1986.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1987.     char *name1;        /* Name of variable or array. */
  1988.     char *name2;        /* Name of element within array;  NULL means
  1989.                  * scalar variable is being referenced. */
  1990.     int flags;            /* OR-ed bits giving operation and other
  1991.                  * information. */
  1992. {
  1993.     Interp *iPtr = (Interp *) interp;
  1994.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1995.     char *result;
  1996.     int code;
  1997.     Interp dummy;
  1998.     Tcl_DString cmd;
  1999.     Tcl_Obj *saveObjPtr, *oldObjResultPtr;
  2000.  
  2001.     result = NULL;
  2002.     if (tvarPtr->errMsg != NULL) {
  2003.     ckfree(tvarPtr->errMsg);
  2004.     tvarPtr->errMsg = NULL;
  2005.     }
  2006.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  2007.  
  2008.     /*
  2009.      * Generate a command to execute by appending list elements
  2010.      * for the two variable names and the operation.  The five
  2011.      * extra characters are for three space, the opcode character,
  2012.      * and the terminating null.
  2013.      */
  2014.  
  2015.     if (name2 == NULL) {
  2016.         name2 = "";
  2017.     }
  2018.     Tcl_DStringInit(&cmd);
  2019.     Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
  2020.     Tcl_DStringAppendElement(&cmd, name1);
  2021.     Tcl_DStringAppendElement(&cmd, name2);
  2022.     if (flags & TCL_TRACE_READS) {
  2023.         Tcl_DStringAppend(&cmd, " r", 2);
  2024.     } else if (flags & TCL_TRACE_WRITES) {
  2025.         Tcl_DStringAppend(&cmd, " w", 2);
  2026.     } else if (flags & TCL_TRACE_UNSETS) {
  2027.         Tcl_DStringAppend(&cmd, " u", 2);
  2028.     }
  2029.  
  2030.     /*
  2031.      * Execute the command.  Be careful to save and restore both the
  2032.      * string and object results from the interpreter used for
  2033.      * the command. We discard any object result the command returns.
  2034.      */
  2035.  
  2036.     dummy.objResultPtr = Tcl_NewObj();
  2037.     Tcl_IncrRefCount(dummy.objResultPtr);
  2038.     if (interp->freeProc == 0) {
  2039.         dummy.freeProc = (Tcl_FreeProc *) 0;
  2040.         dummy.result = "";
  2041.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
  2042.             TCL_VOLATILE);
  2043.     } else {
  2044.         dummy.freeProc = interp->freeProc;
  2045.         dummy.result = interp->result;
  2046.         interp->freeProc = (Tcl_FreeProc *) 0;
  2047.     }
  2048.     
  2049.     saveObjPtr = Tcl_GetObjResult(interp);
  2050.     Tcl_IncrRefCount(saveObjPtr);
  2051.     
  2052.     code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
  2053.     if (code != TCL_OK) {         /* copy error msg to result */
  2054.         tvarPtr->errMsg = (char *)
  2055.             ckalloc((unsigned) (strlen(interp->result) + 1));
  2056.         strcpy(tvarPtr->errMsg, interp->result);
  2057.         result = tvarPtr->errMsg;
  2058.         Tcl_ResetResult(interp); /* must clear error state. */
  2059.     }
  2060.  
  2061.     /*
  2062.      * Restore the interpreter's string result.
  2063.      */
  2064.     
  2065.     Tcl_SetResult(interp, dummy.result,
  2066.         (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
  2067.  
  2068.     /*
  2069.      * Restore the interpreter's object result from saveObjPtr.
  2070.      */
  2071.  
  2072.     oldObjResultPtr = iPtr->objResultPtr;
  2073.     iPtr->objResultPtr = saveObjPtr;  /* was incremented above */
  2074.     Tcl_DecrRefCount(oldObjResultPtr);
  2075.  
  2076.     Tcl_DecrRefCount(dummy.objResultPtr);
  2077.     dummy.objResultPtr = NULL;
  2078.     Tcl_DStringFree(&cmd);
  2079.     }
  2080.     if (flags & TCL_TRACE_DESTROYED) {
  2081.     result = NULL;
  2082.     if (tvarPtr->errMsg != NULL) {
  2083.         ckfree(tvarPtr->errMsg);
  2084.     }
  2085.     ckfree((char *) tvarPtr);
  2086.     }
  2087.     return result;
  2088. }
  2089.  
  2090. /*
  2091.  *----------------------------------------------------------------------
  2092.  *
  2093.  * Tcl_WhileCmd --
  2094.  *
  2095.  *      This procedure is invoked to process the "while" Tcl command.
  2096.  *      See the user documentation for details on what it does.
  2097.  *
  2098.  *    With the bytecode compiler, this procedure is only called when
  2099.  *    a command name is computed at runtime, and is "while" or the name
  2100.  *    to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
  2101.  *
  2102.  * Results:
  2103.  *      A standard Tcl result.
  2104.  *
  2105.  * Side effects:
  2106.  *      See the user documentation.
  2107.  *
  2108.  *----------------------------------------------------------------------
  2109.  */
  2110.  
  2111.         /* ARGSUSED */
  2112. int
  2113. Tcl_WhileCmd(dummy, interp, argc, argv)
  2114.     ClientData dummy;                   /* Not used. */
  2115.     Tcl_Interp *interp;                 /* Current interpreter. */
  2116.     int argc;                           /* Number of arguments. */
  2117.     char **argv;                        /* Argument strings. */
  2118. {
  2119.     int result, value;
  2120.  
  2121.     if (argc != 3) {
  2122.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  2123.                 argv[0], " test command\"", (char *) NULL);
  2124.         return TCL_ERROR;
  2125.     }
  2126.  
  2127.     while (1) {
  2128.         result = Tcl_ExprBoolean(interp, argv[1], &value);
  2129.         if (result != TCL_OK) {
  2130.             return result;
  2131.         }
  2132.         if (!value) {
  2133.             break;
  2134.         }
  2135.         result = Tcl_Eval(interp, argv[2]);
  2136.         if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
  2137.             if (result == TCL_ERROR) {
  2138.                 char msg[60];
  2139.                 sprintf(msg, "\n    (\"while\" body line %d)",
  2140.                         interp->errorLine);
  2141.                 Tcl_AddErrorInfo(interp, msg);
  2142.             }
  2143.             break;
  2144.         }
  2145.     }
  2146.     if (result == TCL_BREAK) {
  2147.         result = TCL_OK;
  2148.     }
  2149.     if (result == TCL_OK) {
  2150.         Tcl_ResetResult(interp);
  2151.     }
  2152.     return result;
  2153. }
  2154.  
  2155.